home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CD ROM Paradise Collection 4
/
CD ROM Paradise Collection 4 1995 Nov.iso
/
program
/
4cmp22s.zip
/
FORTHLIB.4TH
< prev
next >
Wrap
Text File
|
1994-10-30
|
8KB
|
159 lines
\ FORTH COMPILER FORTH-83 LIBRARY 09:29 12/30/91
\ COPYRIGHT 1985 (C) BY THOMAS ALMY. ALL RIGHTS RESERVED
\ Permission is granted to registered users of ForthCMP to
\ sell or distribute computer programs incorporating the compiled
\ contents of this file.
\ SKIP AND SCAN ARE FROM LAXEN & PERRY FORTH 83.
CR .( LOADING FORTHLIB ) CR HEX FORTH
U: #IN PAD DUP 50 ACCEPT NUM? 0= IF 0 ELSE DROP THEN ;
U: NUM? OVER C@ [CHAR] - = IF 1 /STRING TRUE ELSE FALSE THEN
>R 0. 2SWAP >NUMBER IF C@ BL <> IF R> DROP 2DROP 0 EXIT
THEN ELSE DROP THEN R> IF DNEGATE THEN -1 ;
U: CONVERT CHAR+ 65535 >NUMBER DROP ;
U: >NUMBER BEGIN DUP 0= IF EXIT THEN >R DUP >R C@
[CHAR] 0 - DUP 0< IF 0 ELSE DUP 9 > IF 7 - THEN DUP BASE @ <
THEN WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+
R> R> 1 /STRING REPEAT DROP R> R> ;
?DEFINE PARSE ?DEFINE PARSE-WORD ?DEFINE WORD ?DEFINE REFILL ?DEFINE >BUFFER OR OR OR OR [IF]
FIND >IN [IF] DROP [ELSE] VARIABLE >IN [THEN] [THEN]
U: WORD PARSE-WORD 1F MIN DUP HERE C!
DUP HERE + 1+ BL C<- HERE 1+ SWAP CMOVE HERE ;
U: PARSE-WORD >R SOURCE >IN @ /STRING R@ OVER >R SKIP
R> SWAP - >IN +! DROP R> PARSE ;
UNDEF UNUSED CODE UNUSED SI POP
SEPSSEG? 0= [IF] SP AX MOV [ELSE]
SEPDSEG? [IF] dssize 10 * # AX MOV [ELSE]
FIND PSIZE [IF] DROP PSIZE [ELSE] FFFE [THEN] # AX MOV
[THEN] [THEN] DP [] AX SUB AX PUSH SI JMPI END-CODE [THEN]
U: PARSE >R SOURCE >IN @ /STRING OVER SWAP R> SCAN >R OVER -
DUP R> IF 1+ THEN >IN +! ;
UNDEF SKIP ASM L: done CX PUSH BX JMPI
CODE SKIP BX POP AX POP CX POP done LOOP ~ JMPC
DI POP DX DS <SEG DX ES >SEG REPZ BYTE SCAS =0 ~ IF, CX INC
DI DEC THEN, DI PUSH CX PUSH BX JMPI END-CODE [THEN]
UNDEF SCAN FIND done 0= [IF] ASM L: done CX PUSH BX JMPI
[ELSE] DROP [THEN]
CODE SCAN BX POP AX POP CX POP done LOOP ~ JMPC DI POP
DX DS <SEG DX ES >SEG REPNZ BYTE SCAS =0 IF, CX INC DI DEC
THEN, DI PUSH CX PUSH BX JMPI END-CODE [THEN]
?DEFINE REFILL ?DEFINE SOURCE ?DEFINE >BUFFER OR OR [IF]
FIND #TIB [IF] DROP [ELSE] VARIABLE #TIB [THEN] FIND TIB
[IF] DROP [ELSE] DSEG CREATE TIB 80 ALLOT [THEN] [THEN]
U: >BUFFER 80 MIN DUP #TIB ! TIB SWAP CMOVE >IN OFF ;
U: REFILL TIB 80 ACCEPT #TIB ! >IN OFF TRUE ;
PRIMITIVE U: SOURCE TIB #TIB @ ;
U: ACCEPT >R 0 BEGIN KEY CASE
[CTRL] M OF NIP R> DROP EXIT ENDOF
[CTRL] H OF DUP IF 8 EMIT BL EMIT 8 EMIT 1- THEN ENDOF
[CTRL] [ OF 0 ?DO 8 EMIT BL EMIT 8 EMIT LOOP 0 ENDOF
OVER R@ <> IF DUP >R EMIT 2DUP + R> SWAP C! 1+ 0 THEN ENDCASE AGAIN ;
U: DMIN 2OVER 2OVER D< 0= IF 2SWAP THEN 2DROP ;
U: DMAX 2OVER 2OVER D< IF 2SWAP THEN 2DROP ;
PRIMITIVE U: D< ROT SWAP 2DUP <> IF < -ROT 2DROP ELSE 2DROP U< THEN ;
U: DU< ROT SWAP 2DUP <> IF 2SWAP THEN 2DROP U< ;
UNDEF 2SWAP CODE 2SWAP SI POP AX POP BX POP CX POP DX POP
BX PUSH AX PUSH DX PUSH CX PUSH SI JMPI END-CODE [THEN]
U: 2ROT 5 ROLL 5 ROLL ;
PRIMITIVE U: D= ROT = >R = R> AND ;
U: D. 0 D.R SPACE ;
U: D.R >R TUCK DABS <# #S ROT SIGN #> R> OVER - SPACES TYPE ;
UNDEF D2/ CODE D2/ AX 1 SAR BX 1 RCR RET END-CODE [THEN]
UNDEF D2* CODE D2* BX BX ADD AX AX ADC RET END-CODE [THEN]
U: DABS DUP 0< IF DNEGATE THEN ;
U: (.") CS: COUNT 2DUP + -ROT CS:TYPE ;
PRIMITIVE U: HEX 10 BASE ! ;
PRIMITIVE U: DECIMAL 0A BASE ! ;
U: U. 0 <# #S #> TYPE SPACE ;
U: U.R >R 0 <# #S #> R> OVER - SPACES TYPE ;
U: . DUP ABS 0 <# #S ROT SIGN #> TYPE SPACE ;
U: .R >R DUP ABS 0 <# #S ROT SIGN #> R> OVER - SPACES TYPE ;
U: SPACES DUP 0> IF 0 DO SPACE LOOP EXIT THEN DROP ;
FIND EMIT ?DUP [IF] ?DEFINE CS:TYPE [IF]
SEPDSEG? [IF] : CS:TYPE 0 ?DO CS: COUNT EMIT LOOP DROP ;
[ELSE] CODE CS:TYPE END-CODE REQUIRES TYPE [THEN] [THEN]
U: TYPE 0 ?DO COUNT EMIT LOOP DROP ; [THEN]
U: SPACE 20 EMIT ;
U: #S BEGIN # 2DUP OR 0= UNTIL ;
U: # BASE @ MU/MOD ROT 9 OVER < IF 7 + THEN 30 + HOLD ;
U: MU/MOD >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ;
U: SIGN 0< IF 2D HOLD THEN ;
UNDEF HOLD FIND HLD [IF] DROP [ELSE] VARIABLE HLD [THEN]
: HOLD -1 HLD +! HLD @ C! ; [THEN]
U: #> 2DROP HLD @ PAD OVER - ;
U: <# PAD HLD ! ;
UNDEF -TRAILING CODE -TRAILING AX CX MOV BX AX MOV LOOP IF,
CX BX ADD BX DEC BEGIN, 20 # [BX] BYTE CMP =0 IF, BX DEC
SWAP LOOP ~ UNTIL, THEN, AX BX MOV THEN, CX AX MOV RET
END-CODE [THEN]
PRIMITIVE U: /STRING TUCK - -ROT + SWAP ;
UNDEF DEPTH CODE DEPTH S0 [] AX MOV SP AX SUB AX 1 SAR
RET END-CODE [THEN]
ALIGNED? [IF] PRIMITIVE U: ALIGN DP @ 1+ -2 AND DP ! ;
[ELSE] PRIMITIVE U: ALIGN ; [THEN]
U: ALLOT DP +! ;
U: HERE DP @ ;
U: PAD DP @ 64 + ;
U: C, DP @ C! 1 DP +! ;
U: , DP @ ! 2 DP +! ;
U: BLANK BL FILL ;
U: ERASE 0 FILL ;
UNDEF WITHIN CODE WITHIN SI POP AX POP BX POP BX AX SUB
DX POP BX DX SUB AX DX CMP 0 # AX MOV <U IF, AX DEC THEN,
AX PUSH SI JMPI [THEN]
U: MOVE >R 2DUP U< IF R> CMOVE> ELSE R> CMOVE THEN ;
UNDEF CMOVE> CODE CMOVE> BX POP CX POP DI POP SI POP
CX AX MOV AX DEC AX SI ADD AX DI ADD STD AX DS <SEG
AX ES >SEG REPZ BYTE MOVS CLD BX JMPI END-CODE [THEN]
UNDEF CMOVE CODE CMOVE BX POP CX POP DI POP SI POP
AX DS <SEG AX ES >SEG REPZ BYTE MOVS BX JMPI
END-CODE [THEN]
UNDEF FILL CODE FILL BX POP AX POP CX POP DI POP
DX DS <SEG DX ES >SEG REPZ BYTE STOS BX JMPI END-CODE [THEN]
UNDEF ROLL CODE ROLL BX POP DI POP AX SS <SEG AX ES >SEG
DI CX MOV CX INC DI 1 SHL SP DI ADD DI SI MOV SI DEC SI DEC
SS: [DI] PUSH STD CLI REPZ MOVS STI CLD
SP INC SP INC BX JMPI END-CODE [THEN]
UNDEF DNEGATE CODE DNEGATE AX NOT BX NOT 1 # BX ADD
0 # AX ADC RET END-CODE [THEN]
U: KEY 0 8 BDOS ;
U: KEY? 0 0B BDOS 0<> ;
U: CR 0D EMIT 0A EMIT ;
?DEFINE EMIT ?DEFINE TYPE ?DEFINE CS:TYPE ?DEFINE CONSOLE
?DEFINE PRINTER ?DEFINE MESSAGES OR OR OR OR OR [IF]
FIND of [IF] DROP [ELSE] VARIABLE of DSEG 1 of ! [THEN] [THEN]
UNDEF EMIT HERE 1 ALLOT
CODE EMIT AL OVER [] MOV 40 # AH MOV 1 # CX MOV DUP # DX MOV
of [] BX MOV 21 INT RET END-CODE DROP [THEN]
UNDEF CS:TYPE CODE CS:TYPE SEPDSEG? [IF] AX CX MOV BX DX MOV
of [] BX MOV DS PUSHSEG AX CS <SEG AX DS >SEG 40 # AH MOV
21 INT DS POPSEG RET [ELSE] REQUIRES TYPE [THEN] END-CODE [THEN]
UNDEF TYPE CODE TYPE AX CX MOV BX DX MOV of [] BX MOV
40 # AH MOV 21 INT RET END-CODE [THEN]
UNDEF CONSOLE CODE CONSOLE 1 # of [] MOV RET END-CODE [THEN]
UNDEF PRINTER CODE PRINTER 4 # of [] MOV RET END-CODE [THEN]
UNDEF MESSAGES CODE MESSAGES 2 # of [] MOV RET END-CODE [THEN]
UNDEF BDOS CODE BDOS AL AH MOV BX DX MOV 21 INT AH AH XOR RET END-CODE [THEN]
UNDEF BYE CODE BYE ' bye JMP END-CODE [THEN]
UNDEF RETURN CODE RETURN AX POP AX POP 4C # AH MOV 21 INT END-CODE [THEN]
UNDEF CMOVEL CODE CMOVEL BX POP CX POP DI POP ES POPSEG SI POP
DX DS <SEG DS POPSEG REPZ BYTE MOVS
DX DS >SEG BX JMPI END-CODE [THEN]
PRIMITIVE U: 2OVER 3 PICK 3 PICK ;
PRIMITIVE U: */MOD >R M* R> SM/REM ;
UNDEF M*/ CODE M*/ SI POP DI POP BX POP CX POP AX POP
BX BX OR <0 IF, CX NOT AX NOT AX INC 0 # CX ADC BX NOT BX INC
THEN, BX MUL AX CX XCHG DX PUSH BX IMUL
BX POP BX AX ADD 0 # DX ADC DX PUSH
<0 IF, DX NOT AX NOT CX NOT CX INC 0 # AX ADC 0 # DX ADC THEN,
DI DIV DX BX MOV AX BX MOV CX AX MOV DI DIV
DX POP DX DX OR <0 IF, AX NOT BX NOT AX INC 0 # BX ADC THEN,
AX PUSH BX PUSH SI JMPI END-CODE [THEN]
UNDEF (do) CODE (do) 8000 # DX MOV AX DX SUB CX DX ADD
BP DEC BP DEC DX [BP] MOV RET [THEN]
UNDEF (?do) CODE (?do) 8000 # DX MOV AX DX SUB CX DX ADD
BP DEC BP DEC DX [BP] MOV AX CX CMP RET [THEN]